First I want a highly interpolated smoothed data set. Same size bins as usual, but depths by meter, or 1/10 meter. I want the change in flux to be like < 1%.
Then I get adjusted DF for every depth. Then I run remin_shuffle on each depth and extract Cr.
Start with bes. I am assuming I have the usual data. I also have SameGam from GenerateFigures.Rmd, which I think is ready to go.
fine_depths <- seq(from = 1, to = 1500, by = 5)
bds_depths <- unique(bds$depth)
lbbs_FD <- tibble(lb = lb_vec, binsize = binsize_vec)
Expanded_FD <- expand_grid(time = (unique(besE$time)), lb = lb_vec, depth = bds_depths) %>% # undid as.factor of time
left_join(lbbs_FD, by = "lb")
pt0 <- proc.time()
Pred_FD <- exp(predict(SameGam, Expanded_FD))
pt1 <- proc.time()
pt1 - pt0
user system elapsed
5.570 0.127 5.697
Thing_FD <- bind_cols(Expanded_FD, nnparticles = Pred_FD) %>% mutate(nparticles = nnparticles * binsize) # %>% mutate(time = as.character(time))
Too slow Hey. Here’s an idea. Instead of slicing everything super thin, I could just calculate at the BES locations and like 1m below those locations. And then I look at jumps between each depth and the depth below
space <- 0.01
Expanded_FD_Above <- Expanded_FD %>%
mutate(depth = depth - space)
Pred_FD_Above <- exp(predict(SameGam, Expanded_FD_Above))
Thing_FD_Above <- bind_cols(Expanded_FD_Above, nnparticles = Pred_FD_Above) %>% mutate(nparticles = nnparticles * binsize) # %>% mutate(time = as.character(time))
Thing_FD_2 <- bind_cols(Thing_FD, depth_above = Thing_FD_Above$depth, nnparticles_above = Thing_FD_Above$nnparticles, nparticles_above = Thing_FD_Above$nparticles) %>%
mutate(flux = nparticles * C_f_global * lb ^ ag_global,
flux_above = nparticles_above * C_f_global * lb ^ ag_global)
Thing_FD_Nested <- Thing_FD_2 %>% group_by(time, depth) %>%
nest() %>%
mutate(spec_only = map(data, ~pull(., nparticles)),
spec_prev = map(data, ~pull(., nparticles_above))
)
DF = smooth_flux_fit - flux_prev,
#DFP = 1 - DF/flux_prev, # I was using this for a while.
DFP = smooth_flux_fit/flux_prev,
depth_prev = lag(depth),
DZ = depth - depth_prev,
Thing_FD_FSum <- Thing_FD_2 %>% group_by(time, depth, depth_above) %>%
summarize(Flux = sum(flux), Flux_Above = sum(flux_above)) %>%
mutate(DF = Flux - Flux_Above,
DFP = Flux/Flux_Above,
DZ = depth - depth_above)
Thing_FD_FSum
Thing_FD_3 <- left_join(Thing_FD_FSum, Thing_FD_Nested, by = c("time", "depth"))
Thing_FD_3
Thing_FD_4 <- Thing_FD_3 %>%
mutate(use_DFP = map2_dbl(spec_prev, DFP, optFun, llb = little_lb))
Thing_FD_4
Thing_FD_4 %>% ungroup() %>% summarize(DFPMin = min(DFP), UseDFPMin = min(use_DFP))
I’ve been misspecifying alpha and gamma in the remin model.
#loc_rs <- function(abun_in, DFpct, DeltaZ){remin_shuffle()}
Thing_FD_5 <- Thing_FD_4 %>%
mutate(Remin = pmap(list(spec_prev, use_DFP, DZ), remin_shuffle)) %>%
mutate(Cr = map_dbl(Remin, ~.$Cr))
Thing_FD_5
ggplot(Thing_FD_5, aes(y = depth, x = pracma::nthroot(Cr, 5), color = as.factor(time))) + geom_point() + scale_y_reverse(limits = c(1500, 0))

ggplot(Thing_FD_5, aes(y = depth, x = pracma::nthroot(DFP, 5), color = as.factor(time))) + geom_point() + scale_y_reverse(limits = c(1500, 0))

Thing_FD_Slim <- Thing_FD_5 %>% ungroup() %>% select(time, depth, Cr) %>% mutate(time = as.POSIXct(time))
bds_Slim <- bds %>% filter(project == "ETNP") %>% select(profile, time, depth)
bdsCr <- left_join(bds_Slim, Thing_FD_Slim , by = c("time", "depth"))
ggplot(bdsCr, aes(y = depth, x = pracma::nthroot(Cr, 3), color = as.factor(time))) + geom_point() + scale_y_reverse(limits = c(1500, 0)) + scale_x_continuous(limits = c(-0.2, 0.1)) +
geom_hline(aes(yintercept = PhoticBase), color = "darkgreen") + geom_hline(aes(yintercept = OMZBase), color = "darkblue")

LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKRmlyc3QgSSB3YW50IGEgaGlnaGx5IGludGVycG9sYXRlZCBzbW9vdGhlZCBkYXRhIHNldC4KU2FtZSBzaXplIGJpbnMgYXMgdXN1YWwsIGJ1dCBkZXB0aHMgYnkgbWV0ZXIsIG9yIDEvMTAgbWV0ZXIuIEkgd2FudCB0aGUgY2hhbmdlIGluIGZsdXggdG8gYmUgbGlrZSA8IDElLgoKVGhlbiBJIGdldCBhZGp1c3RlZCBERiBmb3IgZXZlcnkgZGVwdGguClRoZW4gSSBydW4gcmVtaW5fc2h1ZmZsZSBvbiBlYWNoIGRlcHRoIGFuZCBleHRyYWN0IENyLgoKClN0YXJ0IHdpdGggYmVzLiBJIGFtIGFzc3VtaW5nIEkgaGF2ZSB0aGUgdXN1YWwgZGF0YS4gSSBhbHNvIGhhdmUgU2FtZUdhbSBmcm9tIEdlbmVyYXRlRmlndXJlcy5SbWQsIHdoaWNoIEkgdGhpbmsgaXMgcmVhZHkgdG8gZ28uCmBgYHtyfQpmaW5lX2RlcHRocyA8LSBzZXEoZnJvbSA9IDEsIHRvID0gMTUwMCwgYnkgPSA1KQpiZHNfZGVwdGhzIDwtIHVuaXF1ZShiZHMkZGVwdGgpCgpsYmJzX0ZEIDwtIHRpYmJsZShsYiA9IGxiX3ZlYywgYmluc2l6ZSA9IGJpbnNpemVfdmVjKQpFeHBhbmRlZF9GRCA8LSBleHBhbmRfZ3JpZCh0aW1lID0gKHVuaXF1ZShiZXNFJHRpbWUpKSwgbGIgPSBsYl92ZWMsIGRlcHRoID0gYmRzX2RlcHRocykgJT4lICMgdW5kaWQgYXMuZmFjdG9yIG9mIHRpbWUKICBsZWZ0X2pvaW4obGJic19GRCwgYnkgPSAibGIiKQoKcHQwIDwtIHByb2MudGltZSgpClByZWRfRkQgPC0gZXhwKHByZWRpY3QoU2FtZUdhbSwgRXhwYW5kZWRfRkQpKQpwdDEgPC0gcHJvYy50aW1lKCkKcHQxIC0gcHQwClRoaW5nX0ZEIDwtIGJpbmRfY29scyhFeHBhbmRlZF9GRCwgbm5wYXJ0aWNsZXMgPSBQcmVkX0ZEKSAgJT4lIG11dGF0ZShucGFydGljbGVzID0gbm5wYXJ0aWNsZXMgKiBiaW5zaXplKSAjICU+JSBtdXRhdGUodGltZSA9IGFzLmNoYXJhY3Rlcih0aW1lKSkKYGBgClRvbyBzbG93CkhleS4gSGVyZSdzIGFuIGlkZWEuIEluc3RlYWQgb2Ygc2xpY2luZyBldmVyeXRoaW5nIHN1cGVyIHRoaW4sIEkgY291bGQganVzdCBjYWxjdWxhdGUgYXQgdGhlIEJFUyBsb2NhdGlvbnMgYW5kIGxpa2UgMW0gYmVsb3cgdGhvc2UgbG9jYXRpb25zLgpBbmQgdGhlbiBJIGxvb2sgYXQganVtcHMgYmV0d2VlbiBlYWNoIGRlcHRoIGFuZCB0aGUgZGVwdGggYmVsb3cKCmBgYHtyfQpzcGFjZSA8LSAwLjAxCkV4cGFuZGVkX0ZEX0Fib3ZlIDwtIEV4cGFuZGVkX0ZEICU+JQogIG11dGF0ZShkZXB0aCA9IGRlcHRoIC0gc3BhY2UpClByZWRfRkRfQWJvdmUgPC0gZXhwKHByZWRpY3QoU2FtZUdhbSwgRXhwYW5kZWRfRkRfQWJvdmUpKQpUaGluZ19GRF9BYm92ZSA8LSBiaW5kX2NvbHMoRXhwYW5kZWRfRkRfQWJvdmUsIG5ucGFydGljbGVzID0gUHJlZF9GRF9BYm92ZSkgICU+JSBtdXRhdGUobnBhcnRpY2xlcyA9IG5ucGFydGljbGVzICogYmluc2l6ZSkgIyAlPiUgbXV0YXRlKHRpbWUgPSBhcy5jaGFyYWN0ZXIodGltZSkpCmBgYAoKYGBge3J9ClRoaW5nX0ZEXzIgPC0gYmluZF9jb2xzKFRoaW5nX0ZELCBkZXB0aF9hYm92ZSA9IFRoaW5nX0ZEX0Fib3ZlJGRlcHRoLCBubnBhcnRpY2xlc19hYm92ZSA9IFRoaW5nX0ZEX0Fib3ZlJG5ucGFydGljbGVzLCBucGFydGljbGVzX2Fib3ZlID0gVGhpbmdfRkRfQWJvdmUkbnBhcnRpY2xlcykgJT4lCiAgbXV0YXRlKGZsdXggPSBucGFydGljbGVzICogQ19mX2dsb2JhbCAqIGxiIF4gYWdfZ2xvYmFsLAogICAgICAgICBmbHV4X2Fib3ZlID0gbnBhcnRpY2xlc19hYm92ZSAqIENfZl9nbG9iYWwgKiBsYiBeIGFnX2dsb2JhbCkKYGBgCgpgYGB7cn0KVGhpbmdfRkRfTmVzdGVkIDwtIFRoaW5nX0ZEXzIgJT4lIGdyb3VwX2J5KHRpbWUsIGRlcHRoKSAlPiUgCiAgbmVzdCgpICU+JQogIG11dGF0ZShzcGVjX29ubHkgPSBtYXAoZGF0YSwgfnB1bGwoLiwgbnBhcnRpY2xlcykpLAogICAgICAgICBzcGVjX3ByZXYgPSBtYXAoZGF0YSwgfnB1bGwoLiwgbnBhcnRpY2xlc19hYm92ZSkpCiAgKQpgYGAKCgogICAgICAgICAgIERGID0gc21vb3RoX2ZsdXhfZml0IC0gZmx1eF9wcmV2LAogICAgICAgICAgICNERlAgPSAxIC0gREYvZmx1eF9wcmV2LCAgIyBJIHdhcyB1c2luZyB0aGlzIGZvciBhIHdoaWxlLgogICAgICAgICAgIERGUCA9IHNtb290aF9mbHV4X2ZpdC9mbHV4X3ByZXYsCiAgICAgICAgICAgZGVwdGhfcHJldiA9IGxhZyhkZXB0aCksCiAgICAgICAgICAgRFogPSBkZXB0aCAtIGRlcHRoX3ByZXYsCgpgYGB7cn0KVGhpbmdfRkRfRlN1bSA8LSBUaGluZ19GRF8yICU+JSBncm91cF9ieSh0aW1lLCBkZXB0aCwgZGVwdGhfYWJvdmUpICU+JSAKICBzdW1tYXJpemUoRmx1eCA9IHN1bShmbHV4KSwgRmx1eF9BYm92ZSA9IHN1bShmbHV4X2Fib3ZlKSkgJT4lCiAgbXV0YXRlKERGID0gRmx1eCAtIEZsdXhfQWJvdmUsCiAgICAgICAgIERGUCA9IEZsdXgvRmx1eF9BYm92ZSwKICAgICAgICAgRFogPSBkZXB0aCAtIGRlcHRoX2Fib3ZlKQoKVGhpbmdfRkRfRlN1bQpgYGAKCmBgYHtyfQpUaGluZ19GRF8zIDwtIGxlZnRfam9pbihUaGluZ19GRF9GU3VtLCBUaGluZ19GRF9OZXN0ZWQsIGJ5ID0gYygidGltZSIsICJkZXB0aCIpKQpUaGluZ19GRF8zCmBgYAoKYGBge3J9ClRoaW5nX0ZEXzQgPC0gVGhpbmdfRkRfMyAlPiUKICBtdXRhdGUodXNlX0RGUCA9IG1hcDJfZGJsKHNwZWNfcHJldiwgREZQLCBvcHRGdW4sIGxsYiA9IGxpdHRsZV9sYikpClRoaW5nX0ZEXzQKYGBgCgpgYGB7cn0KVGhpbmdfRkRfNCAlPiUgdW5ncm91cCgpICU+JSBzdW1tYXJpemUoREZQTWluID0gbWluKERGUCksIFVzZURGUE1pbiA9IG1pbih1c2VfREZQKSkKYGBgCgpJJ3ZlIGJlZW4gbWlzc3BlY2lmeWluZyBhbHBoYSBhbmQgZ2FtbWEgaW4gdGhlIHJlbWluIG1vZGVsLgpgYGB7cn0KI2xvY19ycyA8LSBmdW5jdGlvbihhYnVuX2luLCBERnBjdCwgRGVsdGFaKXtyZW1pbl9zaHVmZmxlKCl9ClRoaW5nX0ZEXzUgPC0gVGhpbmdfRkRfNCAlPiUKICBtdXRhdGUoUmVtaW4gPSBwbWFwKGxpc3Qoc3BlY19wcmV2LCB1c2VfREZQLCBEWiksIHJlbWluX3NodWZmbGUpKSAlPiUKICBtdXRhdGUoQ3IgPSBtYXBfZGJsKFJlbWluLCB+LiRDcikpClRoaW5nX0ZEXzUKYGBgCgpgYGB7cn0KZ2dwbG90KFRoaW5nX0ZEXzUsIGFlcyh5ID0gZGVwdGgsIHggPSBwcmFjbWE6Om50aHJvb3QoQ3IsIDUpLCBjb2xvciA9IGFzLmZhY3Rvcih0aW1lKSkpICsgZ2VvbV9wb2ludCgpICsgc2NhbGVfeV9yZXZlcnNlKGxpbWl0cyA9IGMoMTUwMCwgMCkpCmBgYAoKYGBge3J9CmdncGxvdChUaGluZ19GRF81LCBhZXMoeSA9IGRlcHRoLCB4ID0gcHJhY21hOjpudGhyb290KERGUCwgNSksIGNvbG9yID0gYXMuZmFjdG9yKHRpbWUpKSkgKyBnZW9tX3BvaW50KCkgKyBzY2FsZV95X3JldmVyc2UobGltaXRzID0gYygxNTAwLCAwKSkKYGBgCgpgYGB7cn0KVGhpbmdfRkRfU2xpbSA8LSBUaGluZ19GRF81ICU+JSB1bmdyb3VwKCkgJT4lIHNlbGVjdCh0aW1lLCBkZXB0aCwgQ3IpICU+JSBtdXRhdGUodGltZSA9IGFzLlBPU0lYY3QodGltZSkpCmJkc19TbGltIDwtIGJkcyAlPiUgZmlsdGVyKHByb2plY3QgPT0gIkVUTlAiKSAlPiUgc2VsZWN0KHByb2ZpbGUsIHRpbWUsIGRlcHRoKQpgYGAKCgpgYGB7cn0KYmRzQ3IgPC0gbGVmdF9qb2luKGJkc19TbGltLCBUaGluZ19GRF9TbGltICwgYnkgPSBjKCJ0aW1lIiwgImRlcHRoIikpCmBgYAoKYGBge3J9CmdncGxvdChiZHNDciwgYWVzKHkgPSBkZXB0aCwgeCA9IHByYWNtYTo6bnRocm9vdChDciwgMyksIGNvbG9yID0gYXMuZmFjdG9yKHRpbWUpKSkgKyBnZW9tX3BvaW50KCkgKyBzY2FsZV95X3JldmVyc2UobGltaXRzID0gYygxNTAwLCAwKSkgKyBzY2FsZV94X2NvbnRpbnVvdXMobGltaXRzID0gYygtMC4yLCAwLjEpKSArCiAgZ2VvbV9obGluZShhZXMoeWludGVyY2VwdCA9IFBob3RpY0Jhc2UpLCBjb2xvciA9ICJkYXJrZ3JlZW4iKSArIGdlb21faGxpbmUoYWVzKHlpbnRlcmNlcHQgPSBPTVpCYXNlKSwgY29sb3IgPSAiZGFya2JsdWUiKQpgYGAKCg==